home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / psgml / psgml-dtd.el.z / psgml-dtd.el
Encoding:
Text File  |  1998-05-21  |  27.8 KB  |  926 lines
  1. ;;;; psgml-dtd.el --- DTD parser for SGML-editing mode with parsing support
  2. ;; $Id: psgml-dtd.el,v 2.15 1996/11/11 00:43:45 lenst Exp $
  3.  
  4. ;; Copyright (C) 1994 Lennart Staflin
  5.  
  6. ;; Author: Lennart Staflin <lenst@lysator.liu.se>
  7.  
  8. ;; This program is free software; you can redistribute it and/or
  9. ;; modify it under the terms of the GNU General Public License
  10. ;; as published by the Free Software Foundation; either version 2
  11. ;; of the License, or (at your option) any later version.
  12. ;; 
  13. ;; This program is distributed in the hope that it will be useful,
  14. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16. ;; GNU General Public License for more details.
  17. ;; 
  18. ;; You should have received a copy of the GNU General Public License
  19. ;; along with this program; if not, write to the Free Software
  20. ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  21.  
  22.  
  23. ;;;; Commentary:
  24.  
  25. ;; Part of major mode for editing the SGML document-markup language.
  26.  
  27.  
  28. ;;;; Code:
  29.  
  30. (provide 'psgml-dtd)
  31. (require 'psgml)
  32. (require 'psgml-parse)
  33.  
  34.  
  35. ;;;; Variables
  36.  
  37. ;; Variables used during doctype parsing and loading
  38. (defvar sgml-used-pcdata nil
  39.   "True if model group built is mixed")
  40.  
  41.  
  42. ;;;; Constructing basic
  43.  
  44. (defun sgml-copy-moves (s1 s2)
  45.   "Copy all moves from S1 to S2, keeping their status."
  46.   (let ((l (sgml-state-opts s1)))
  47.     (while l
  48.       (sgml-add-opt-move s2
  49.              (sgml-move-token (car l))
  50.              (sgml-move-dest (car l)))
  51.       (setq l (cdr l)))
  52.     (setq l (sgml-state-reqs s1))
  53.     (while l
  54.       (sgml-add-req-move s2
  55.              (sgml-move-token (car l))
  56.              (sgml-move-dest (car l)))
  57.       (setq l (cdr l)))))
  58.  
  59. (defun sgml-copy-moves-to-opt (s1 s2)
  60.   "Copy all moves from S1 to S2 as optional moves."
  61.   (let ((l (sgml-state-opts s1)))
  62.     (while l
  63.       (sgml-add-opt-move s2
  64.              (sgml-move-token (car l))
  65.              (sgml-move-dest (car l)))
  66.       (setq l (cdr l)))
  67.     (setq l (sgml-state-reqs s1))
  68.     (while l
  69.       (sgml-add-opt-move s2
  70.              (sgml-move-token (car l))
  71.              (sgml-move-dest (car l)))
  72.       (setq l (cdr l)))))
  73.  
  74.  
  75. (defun sgml-some-states-of (state)
  76.   ;; List of some states reachable from STATE, includes all final states
  77.   (let* ((states (list state))
  78.      (l states)
  79.      s ms m)
  80.     (while l
  81.       (setq s (car l)
  82.         ms (append (sgml-state-opts s) (sgml-state-reqs s)))
  83.       (while ms
  84.     (setq m (sgml-move-dest (car ms))
  85.           ms (cdr ms))
  86.     (unless (sgml-normal-state-p m)
  87.       (setq m (sgml-and-node-next m)))
  88.     (unless (memq m states)
  89.       (nconc states (list m))))
  90.       (setq l (cdr l)))
  91.     states))
  92.  
  93. (defmacro sgml-for-all-final-states (s dfa &rest forms)
  94.   "For all final states S in DFA do FORMS.
  95. Syntax: var dfa-expr &body forms"
  96.   (` (let ((L-states (sgml-some-states-of (, dfa)))
  97.        (, s))
  98.        (while L-states
  99.      (when (sgml-state-final-p (setq (, s) (car L-states)))
  100.        (,@ forms))
  101.      (setq L-states (cdr L-states))))))
  102.  
  103. (put 'sgml-for-all-final-states 'lisp-indent-hook 2)
  104. (put 'sgml-for-all-final-states 'edebug-form-hook '(symbolp &rest form))
  105.  
  106.  
  107. ;;;; Optimization for the dfa building
  108.  
  109. (defsubst sgml-empty-state-p (s)
  110.   ;; True if S hase no outgoing moves
  111.   (and (sgml-normal-state-p s)
  112.        (null (sgml-state-reqs s))
  113.        (null (sgml-state-opts s)))  )
  114.  
  115. (defun sgml-one-final-state (s)
  116.   ;; Collaps all states that have no moves
  117.   ;; This is a safe optimization, useful for (..|..|..)
  118.   (sgml-debug "OPT one final: reqs %d opts %d"
  119.           (length (sgml-state-reqs s))
  120.           (length (sgml-state-opts s)))
  121.   (let ((final nil)
  122.     dest)
  123.     (loop for m in (append (sgml-state-reqs s)
  124.                (sgml-state-opts s))
  125.       do
  126.       (setq dest (sgml-move-dest m))
  127.       (when (sgml-empty-state-p dest)
  128.         (cond ((null final)
  129.            (setq final dest))
  130.           (t
  131.            (setf (sgml-move-dest m) final)))))))
  132.  
  133. (defun sgml-states-equal (s1 s2)
  134.   (and (= (length (sgml-state-opts s1))
  135.       (length (sgml-state-opts s2)))
  136.        (= (length (sgml-state-reqs s1))
  137.       (length (sgml-state-reqs s2)))
  138.        (loop for m in (sgml-state-opts s1)
  139.          always
  140.          (eq (sgml-move-dest m)
  141.          (sgml-move-dest (sgml-moves-lookup (sgml-move-token m)
  142.                             (sgml-state-opts s2)))))
  143.        (loop for m in (sgml-state-reqs s1)
  144.          always
  145.          (eq (sgml-move-dest m)
  146.          (sgml-move-dest (sgml-moves-lookup (sgml-move-token m)
  147.                             (sgml-state-reqs s2)))))))
  148.  
  149. (defun sgml-remove-redundant-states-1 (s)
  150.   ;; Remove states accessible from s with one move and equivalent to s,
  151.   ;; by changing the moves from s.
  152.   (sgml-debug "OPT redundant-1: reqs %d opts %d"
  153.           (length (sgml-state-reqs s))
  154.           (length (sgml-state-opts s)))
  155.   (let ((yes nil)
  156.     (no (list s))
  157.     (l (sgml-state-reqs s))
  158.     (nl (sgml-state-opts s))
  159.     dest)
  160.     (while (or l (setq l (prog1 nl (setq nl nil))))
  161.       (cond
  162.        ((not (sgml-normal-state-p (setq dest (sgml-move-dest (car l))))))
  163.        ((memq dest no))
  164.        ((memq dest yes))
  165.        ((sgml-states-equal s dest)
  166.     (progn (push dest yes))))
  167.       (setq l (cdr l)))
  168.     (setq l (sgml-state-opts s)
  169.       nl (sgml-state-reqs s))
  170.     (when yes
  171.       (sgml-debug "OPT redundant-1: sucess %s" (length yes))
  172.       (while (or l (setq l (prog1 nl (setq nl nil))))
  173.     (cond ((memq (sgml-move-dest (car l)) yes)
  174.            (setf (sgml-move-dest (car l)) s)))
  175.     (setq l (cdr l))))))
  176.       
  177.  
  178.  
  179. ;;;; Constructing
  180.  
  181. (defun sgml-make-opt (s1)
  182.   (when (sgml-state-reqs s1)
  183.     (setf (sgml-state-opts s1)
  184.       (nconc (sgml-state-opts s1)
  185.          (sgml-state-reqs s1)))
  186.     (setf (sgml-state-reqs s1) nil))
  187.   s1)
  188.  
  189. (defun sgml-make-* (s1)
  190.   (setq s1 (sgml-make-+ s1))
  191.   (when (sgml-state-reqs s1)
  192.     (sgml-make-opt s1))
  193.   (sgml-remove-redundant-states-1 s1)
  194.   s1)
  195.  
  196. (defun sgml-make-+ (s1)
  197.   (sgml-for-all-final-states s s1
  198.     (sgml-copy-moves-to-opt s1 s))
  199.   (sgml-remove-redundant-states-1 s1)    ; optimize
  200.   s1)
  201.  
  202. (defun sgml-make-conc (s1 s2)
  203.   (let ((moves (append (sgml-state-reqs s1) (sgml-state-opts s1))))
  204.     (cond
  205.      (;; optimize the case where all moves from s1 goes to empty states
  206.       (loop for m in moves
  207.         always (sgml-empty-state-p (sgml-move-dest m)))
  208.       (loop for m in moves do (setf (sgml-move-dest m) s2))
  209.       (when (sgml-state-final-p s1)
  210.     (sgml-copy-moves s2 s1)))
  211.      (t                    ; general case
  212.       (sgml-for-all-final-states s s1
  213.     (sgml-copy-moves s2 s)
  214.     (sgml-remove-redundant-states-1 s)))))
  215.   s1)
  216.  
  217. (defun sgml-make-pcdata ()
  218.   (sgml-make-* (sgml-make-primitive-content-token sgml-pcdata-token)))
  219.  
  220. (defun sgml-reduce-, (l)
  221.   (while (cdr l)
  222.     (setcar (cdr l)
  223.         (sgml-make-conc (car l) (cadr l)))
  224.     (setq l (cdr l)))
  225.   (car l))
  226.  
  227. (defun sgml-reduce-| (l)
  228.   (while (cdr l)            ; apply the binary make-alt
  229.     (cond ((or (sgml-state-final-p (car l))    ; is result optional
  230.            (sgml-state-final-p (cadr l)))
  231.        (sgml-make-opt (car l))
  232.        (sgml-copy-moves-to-opt (cadr l) (car l)))
  233.       (t
  234.        (sgml-copy-moves (cadr l) (car l))))
  235.     (setcdr l (cddr l)))
  236.   (sgml-one-final-state (car l))    ; optimization
  237.   (car l))
  238.  
  239. (defun sgml-make-& (dfas)
  240.   (let ((&n (sgml-make-and-node dfas (sgml-make-state)))
  241.     (s (sgml-make-state))
  242.     (l dfas))
  243.     (while l                ; For each si:
  244.       ;; For m in opts(si): add optional move from s to &n on token(m).
  245.       (loop for m in (sgml-state-opts (car l))
  246.         do (sgml-add-opt-move s (sgml-move-token m) &n))
  247.       ;; For m in reqs(si): add required move from s to &n on token(m).
  248.       (loop for m in (sgml-state-reqs (car l))
  249.         do (sgml-add-req-move s (sgml-move-token m) &n))
  250.       (setq l (cdr l)))
  251.     ;; Return s.
  252.     s))
  253.  
  254.  
  255.  
  256. ;(sgml-make-conc (sgml-make-primitive-content-token 'para) (sgml-make-primitive-content-token 'list))
  257. ;(sgml-make-conc (sgml-make-& (list (sgml-make-primitive-content-token 'para) (sgml-make-primitive-content-token 'list))) (sgml-make-primitive-content-token 'foo))
  258.  
  259. ;(setq x  (sgml-some-states-of  (sgml-make-primitive-content-token 'para))) 
  260. ;(sgml-state-final-p (car x) ) 
  261. ;(sgml-state-final-p (cadr x)) 
  262.  
  263.  
  264. ;;;; Parse doctype: General
  265.  
  266. (defun sgml-skip-ts ()
  267.   ;; Skip over ts*
  268.   ;;70  ts   = 5 s | EE | 60+ parameter entity reference
  269.   ;;For simplicity I use ps*
  270.   ;;65  ps   = 5 s | EE | 60+ parameter entity reference | 92 comment
  271.   ;;*** some comments are accepted that shouldn't
  272.   (sgml-skip-ps))
  273.  
  274. (defun sgml-parse-character-reference (&optional dofunchar)
  275.   ;; *** Actually only numerical character references
  276.   ;; I don't know how to handel the function character references.
  277.   ;; For the shortrefs let's give them numeric values.
  278.   (if (if dofunchar
  279.       (sgml-parse-delim "CRO" (digit nmstart))
  280.     (sgml-parse-delim "CRO" (digit)))
  281.       (prog1 (if (sgml-is-delim "NULL" digit)
  282.          (string-to-int (sgml-check-nametoken))
  283.            (let ((spec (sgml-check-name)))
  284.          (or (cdr (assoc spec '(("re" . 10)
  285.                     ("rs" . 1)
  286.                     ("tab" . 9)
  287.                     ("space" . 32))))
  288.              ;; *** What to do with other names?
  289.              127)))
  290.     (or (sgml-parse-delim "REFC")
  291.         (sgml-parse-RE)))))
  292.  
  293. (defun sgml-parse-parameter-literal (&optional dofunchar)
  294.   (let* (lita                ; flag if lita
  295.      (value                ; accumulates literals value
  296.       "")
  297.      (original-buffer        ; Buffer (entity) where lit started
  298.       (current-buffer))
  299.      temp
  300.      )
  301.     (cond
  302.      ((or (sgml-parse-delim "LIT")
  303.       (setq lita (sgml-parse-delim "LITA")))
  304.       (while (not (and (eq (current-buffer) original-buffer)
  305.                (if lita
  306.                (sgml-parse-delim "LITA")
  307.              (sgml-parse-delim "LIT"))))
  308.     (cond ((eobp)
  309.            (or (sgml-pop-entity)
  310.            (sgml-error "Parameter literal unterminated")))
  311.           ((sgml-parse-parameter-entity-ref))
  312.           ((setq temp (sgml-parse-character-reference dofunchar))
  313.            (setq value (concat value (if (< temp 256)
  314.                          (format "%c" temp)
  315.                        (format "&#%d;" temp)))))
  316.           (t
  317.            (setq value
  318.              (concat value
  319.                  (buffer-substring
  320.                   (point)
  321.                   (progn (forward-char 1)
  322.                      (if lita
  323.                      (sgml-skip-upto ("LITA" "PERO" "CRO"))
  324.                        (sgml-skip-upto ("LIT" "PERO" "CRO")))
  325.                      (point)))))))
  326.     )
  327.       value))))
  328.  
  329. (defun sgml-check-parameter-literal ()
  330.   (or (sgml-parse-parameter-literal)
  331.       (sgml-parse-error "Parameter literal expected")))
  332.  
  333. (defsubst sgml-parse-connector ()
  334.   (sgml-skip-ps)
  335.   (cond ((sgml-parse-delim "SEQ")
  336.      (function sgml-reduce-,))
  337.     ((sgml-parse-delim "OR")
  338.      (function sgml-reduce-|))
  339.     ((sgml-parse-delim "AND")
  340.      (function sgml-make-&))))
  341.  
  342. (defun sgml-parse-name-group ()
  343.   "Parse a single name or a name group (general name case) .
  344. Returns a list of strings or nil."
  345.   (let (names)
  346.     (cond
  347.      ((sgml-parse-delim "GRPO")
  348.       (sgml-skip-ps)
  349.       (setq names (sgml-parse-name-group)) ; *** Allows more than it should
  350.       (while (sgml-parse-connector)
  351.     (sgml-skip-ps)
  352.     (nconc names (sgml-parse-name-group)))
  353.       (sgml-check-delim "GRPC")
  354.       names)
  355.      ((setq names (sgml-parse-name))
  356.       (list names)))))
  357.  
  358. (defun sgml-check-name-group ()
  359.   (or (sgml-parse-name-group)
  360.       (sgml-parse-error "Expecting a name or a name group")))
  361.  
  362. (defun sgml-check-nametoken-group ()
  363.   "Parse a name token group, return a list of strings.
  364. Case transformed for general names."
  365.   (sgml-skip-ps)
  366.   (let ((names nil))
  367.     (cond
  368.      ((sgml-parse-delim GRPO)
  369.       (while (progn
  370.            (sgml-skip-ps)
  371.            (push (sgml-general-case (sgml-check-nametoken)) names)
  372.            (sgml-parse-connector)))
  373.       (sgml-check-delim GRPC)
  374.       (nreverse names))            ; store in same order as declared
  375.      (t
  376.       (list (sgml-general-case (sgml-check-nametoken)))))))
  377.  
  378. (defun sgml-check-element-type ()
  379.   "Parse and check an element type, returns list of strings."
  380. ;;; 117  element type     =  [[30 generic identifier]]
  381. ;;;                      |  [[69 name group]]
  382. ;;;                      |  [[118 ranked element]]
  383. ;;;                      |  [[119 ranked group]]
  384.   (cond
  385.    ((sgml-parse-delim GRPO)
  386.     (sgml-skip-ts)
  387.     (let ((names (list (sgml-check-name))))
  388.       (while (progn (sgml-skip-ts)
  389.             (sgml-parse-connector))
  390.     (sgml-skip-ts)
  391.     (nconc names (list (sgml-check-name))))
  392.       (sgml-check-delim GRPC)
  393.       ;; A ranked group will have a rank suffix here
  394.       (sgml-skip-ps)
  395.       (if (sgml-is-delim "NULL" digit)
  396.     (let ((suffix (sgml-parse-nametoken)))
  397.       (loop for n in names
  398.         collect (concat n suffix)))
  399.     names)))
  400.    (t                    ; gi/ranked element
  401.     (let ((name (sgml-check-name)))
  402.       (sgml-skip-ps)
  403.       (list (if (sgml-is-delim "NULL" digit)
  404.         (concat name (sgml-check-nametoken))
  405.           name))))))
  406.  
  407.  
  408. (defun sgml-check-external ()
  409.   (or (sgml-parse-external)
  410.       (sgml-parse-error "Expecting a PUBLIC or SYSTEM")))
  411.  
  412. ;;;; Parse doctype: notation
  413.  
  414. (defun sgml-declare-notation ()
  415.   ;;148  notation declaration = MDO, "NOTATION",
  416.   ;;                        65 ps+, 41 notation name,
  417.   ;;                        65 ps+, 149 notation identifier,
  418.   ;;                        65 ps*, MDC
  419.   ;;41   notation name    = 55 name
  420.   ;;149  notation identifier = 73 external identifier
  421.   (sgml-skip-ps)
  422.   (sgml-check-name)
  423.   (sgml-skip-ps)
  424.   (sgml-check-external))
  425.  
  426.  
  427. ;;;; Parse doctype: Element
  428.  
  429. (defun sgml-parse-opt ()
  430.   (sgml-skip-ps)
  431.   (cond ((or (sgml-parse-char ?o)
  432.          (sgml-parse-char ?O))
  433.      t)
  434.     ((sgml-parse-char ?-)
  435.      nil)))
  436.  
  437. (defun sgml-parse-modifier ()
  438.   (cond ((sgml-parse-delim PLUS)
  439.      (function sgml-make-+))
  440.     ((sgml-parse-delim REP)
  441.      (function sgml-make-*))
  442.     ((sgml-parse-delim OPT)
  443.      (function sgml-make-opt))))
  444.  
  445. (defun sgml-check-primitive-content-token ()
  446.   (sgml-make-primitive-content-token
  447.    (sgml-eltype-token
  448.     (sgml-lookup-eltype
  449.      (sgml-check-name)))))
  450.  
  451. (defun sgml-check-model-group ()
  452.   (sgml-skip-ps)
  453.   (let (el mod)
  454.     (cond
  455.      ((sgml-parse-delim "GRPO")
  456.       (let ((subs (list (sgml-check-model-group)))
  457.         (con1 nil)
  458.         (con2 nil))
  459.     (while (setq con2 (sgml-parse-connector))
  460.       (cond ((and con1
  461.               (not (eq con1 con2)))
  462.          (sgml-parse-error "Mixed connectors")))
  463.       (setq con1 con2)
  464.       (setq subs (nconc subs (list (sgml-check-model-group)))))
  465.     (sgml-check-delim "GRPC")
  466.     (setq el (if con1
  467.              (funcall con1 subs)
  468.            (car subs)))))
  469.      ((sgml-parse-rni "pcdata")        ; #PCDATA
  470.       (setq sgml-used-pcdata t)
  471.       (setq el (sgml-make-pcdata)))
  472.      ((sgml-parse-delim "DTGO")            ; data tag group
  473.       (sgml-skip-ts)
  474.       (let ((tok (sgml-check-primitive-content-token)))
  475.     (sgml-skip-ts) (sgml-check-delim "SEQ")
  476.     (sgml-skip-ts) (sgml-check-data-tag-pattern)
  477.     (sgml-skip-ts) (sgml-check-delim "DTGC")
  478.     (setq el (sgml-make-conc tok (sgml-make-pcdata)))
  479.     (setq sgml-used-pcdata t)))
  480.      (t
  481.       (setq el (sgml-check-primitive-content-token))))
  482.     (setq mod (sgml-parse-modifier))
  483.     (if mod
  484.     (funcall mod el)
  485.       el)))
  486.  
  487. (defun sgml-check-data-tag-pattern ()
  488.   ;; 134  data tag pattern 
  489.   ;; template | template group
  490.   (cond ((sgml-parse-delim GRPO)
  491.      (sgml-skip-ts)
  492.      (sgml-check-parameter-literal)    ; data tag template,
  493.      (while (progn (sgml-skip-ts)
  494.                (sgml-parse-delim OR))
  495.        (sgml-skip-ts)
  496.        (sgml-check-parameter-literal)) ; data tag template
  497.      (sgml-skip-ts)
  498.      (sgml-check-delim GRPC))
  499.     (t
  500.      (sgml-check-parameter-literal))) ; data tag template
  501.   (sgml-skip-ts)
  502.   (when (sgml-parse-delim SEQ)
  503.     (sgml-check-parameter-literal)))    ; data tag padding template
  504.  
  505. (defun sgml-check-content-model ()
  506.   (sgml-check-model-group))
  507.  
  508. (defun sgml-check-content ()
  509.   (sgml-skip-ps)
  510.   (cond ((sgml-is-delim GRPO)
  511.      (sgml-check-content-model))
  512.     (t
  513.      ;; ANY, CDATA, RCDATA or EMPTY
  514.      (let ((dc (intern (upcase (sgml-check-name))))) 
  515.        (when (eq dc 'ANY)
  516.          (setq sgml-used-pcdata t))
  517.        dc))))
  518.  
  519. (defun sgml-parse-exeption (type)
  520.   (sgml-skip-ps)
  521.   (if (sgml-parse-char type)
  522.       (mapcar (function sgml-lookup-eltype)
  523.           (sgml-check-name-group))))
  524.  
  525. (defun sgml-before-eltype-modification ()
  526. ;;;  (let ((merged (sgml-dtd-merged sgml-dtd-info)))
  527. ;;;    (when (and merged
  528. ;;;           (eq (sgml-dtd-eltypes sgml-dtd-info)
  529. ;;;           (sgml-dtd-eltypes (cdr merged))))
  530. ;;;      (setf (sgml-dtd-eltypes sgml-dtd-info)
  531. ;;;        (sgml-merge-eltypes (sgml-make-eltypes-table)
  532. ;;;                (sgml-dtd-eltypes sgml-dtd-info)))))
  533.   )
  534.  
  535. (defun sgml-declare-element ()
  536.   (let* ((names (sgml-check-element-type))
  537.      (stag-opt (sgml-parse-opt))
  538.      (etag-opt (sgml-parse-opt))
  539.      (sgml-used-pcdata nil)
  540.      (model (sgml-check-content))
  541.      (exclusions (sgml-parse-exeption ?-))
  542.      (inclusions (sgml-parse-exeption ?+)))
  543.     (sgml-before-eltype-modification)
  544.     (while names
  545.       (sgml-debug "Defining element %s" (car names))
  546.       (let ((et (sgml-lookup-eltype (car names))))
  547.     (setf (sgml-eltype-stag-optional et) stag-opt
  548.           (sgml-eltype-etag-optional et) etag-opt
  549.           (sgml-eltype-model et) model
  550.           (sgml-eltype-mixed et) sgml-used-pcdata
  551.           (sgml-eltype-excludes et) exclusions
  552.           (sgml-eltype-includes et) inclusions))
  553.       (setq names (cdr names)))
  554.     (sgml-lazy-message "Parsing doctype (%s elements)..."
  555.                (incf sgml-no-elements))))
  556.  
  557. ;;;; Parse doctype: Entity
  558.  
  559. (defun sgml-declare-entity ()
  560.   (let (name                ; Name of entity
  561.     dest                ; Entity table
  562.     (type 'text)            ; Type of entity
  563.     text                ; Text of entity
  564.     extid                ; External id 
  565.     )
  566.     (cond
  567.      ((sgml-parse-delim "PERO")        ; parameter entity declaration
  568.       (sgml-skip-ps)
  569.       (setq name (sgml-check-name t))
  570.       (setq dest (sgml-dtd-parameters sgml-dtd-info)))
  571.      (t                    ; normal entity declaration
  572.       (or (sgml-parse-rni "default")
  573.       (setq name (sgml-check-name t)))
  574.       (setq dest (sgml-dtd-entities sgml-dtd-info))))
  575.     (sgml-skip-ps)
  576.     ;;105  entity text  = 66 parameter literal
  577.     ;;                 | 106 data text
  578.     ;;                 | 107 bracketed text
  579.     ;;                 | 108 external entity specification
  580.     (setq extid (sgml-parse-external))
  581.     (setq text
  582.       (cond
  583.        (extid            ; external entity specification =
  584.                     ; 73 external identifier,
  585.                     ; (65 ps+, 109+ entity type)?
  586.         (sgml-skip-ps)
  587.         (setq type (or (sgml-parse-entity-type) 'text))
  588.         extid)
  589.        ((sgml-startnm-char-next)
  590.         (let ((token (intern (sgml-check-name))))
  591.           (sgml-skip-ps)
  592.           (cond
  593.            ((memq token '(cdata sdata)) ; data text ***
  594.         (setq type token)
  595.         (sgml-check-parameter-literal))
  596.            ((eq token 'pi)
  597.         (concat "<?" (sgml-check-parameter-literal) ">"))
  598.            ((eq token 'starttag)
  599.         (sgml-start-tag-of (sgml-check-parameter-literal)))
  600.            ((eq token 'endtag)
  601.         (sgml-end-tag-of (sgml-check-parameter-literal)))    
  602.            ((eq token 'ms)        ; marked section
  603.         (concat "<![" (sgml-check-parameter-literal) "]]>"))
  604.            ((eq token 'md)        ; Markup declaration
  605.         (concat "<!" (sgml-check-parameter-literal) ">")))))
  606.        ((sgml-check-parameter-literal))))
  607.     (when dest
  608.       (sgml-entity-declare name dest type text))))
  609.  
  610.  
  611. (defun sgml-parse-entity-type ()
  612.   ;;109+ entity type      = "SUBDOC"
  613.   ;;                      | (("CDATA" | "NDATA" | "SDATA"),
  614.   ;;                             65 ps+,
  615.   ;;                             41 notation name,
  616.   ;;                             149.2+ data attribute specification?)
  617.   (let ((type (sgml-parse-name)))
  618.     (when type
  619.       (setq type (intern (downcase type)))
  620.       (cond ((eq type 'subdoc))
  621.         ((memq type '(cdata ndata sdata))
  622.          (sgml-skip-ps)
  623.          (sgml-check-name)
  624.          ;;149.2+ data attribute specification
  625.          ;;                      = 65 ps+, DSO,
  626.          ;;                        31 attribute specification list,
  627.          ;;                        5 s*, DSC
  628.          (sgml-skip-ps)
  629.          (when (sgml-parse-delim DSO)
  630.            (sgml-parse-attribute-specification-list)
  631.            (sgml-parse-s)
  632.            (sgml-check-delim DSC)))
  633.         (t (sgml-error "Illegal entity type: %s" type))))
  634.     type))
  635.  
  636.  
  637. ;;;; Parse doctype: Attlist
  638.  
  639. (defun sgml-declare-attlist ()
  640.   (let* ((assnot (cond ((sgml-parse-rni "notation")
  641.             (sgml-skip-ps)
  642.             t)))
  643.      (assel (sgml-check-name-group))
  644.      (attlist nil)            ; the list
  645.      (attdef nil))
  646.     (while (setq attdef (sgml-parse-attribute-definition))
  647.       (push attdef attlist))
  648.     (setq attlist (nreverse attlist))
  649.     (unless assnot
  650.       (sgml-before-eltype-modification)
  651.       (loop for elname in assel do
  652.         (setf (sgml-eltype-attlist (sgml-lookup-eltype elname))
  653.           attlist)))))
  654.  
  655. (defun sgml-parse-attribute-definition ()
  656.   (sgml-skip-ps)
  657.   (if (sgml-is-delim MDC) ; End of attlist?
  658.       nil
  659.     (sgml-make-attdecl (sgml-check-name)
  660.                (sgml-check-declared-value)
  661.                (sgml-check-default-value))))
  662.  
  663. (defun sgml-check-declared-value ()
  664.   (sgml-skip-ps)
  665.   (let ((type 'name-token-group)
  666.     (names nil))
  667.     (unless (eq (following-char) ?\()
  668.       (setq type (intern (sgml-check-name)))
  669.       (sgml-skip-ps))
  670.     (when (memq type '(name-token-group notation))
  671.       (setq names (sgml-check-nametoken-group)))
  672.     (sgml-make-declared-value type names)))
  673.  
  674. (defun sgml-check-default-value ()
  675.   (sgml-skip-ps)
  676.   (let* ((rni (sgml-parse-rni))
  677.      (key (if rni (intern (sgml-check-name)))))
  678.     (sgml-skip-ps)
  679.     (sgml-make-default-value
  680.      key
  681.      (if (or (not rni) (eq key 'fixed))
  682.      (sgml-check-attribute-value-specification)))))
  683.  
  684.  
  685. ;;;; Parse doctype: Shortref
  686.  
  687. ;;;150  short reference mapping declaration = MDO, "SHORTREF",
  688. ;;;                        [[65 ps]]+, [[151 map name]],
  689. ;;;                        ([[65 ps]]+, [[66 parameter literal]],
  690. ;;;                        [[65 ps]]+, [[55 name]])+,
  691. ;;;                        [[65 ps]]*, MDC
  692.  
  693. (defun sgml-declare-shortref ()
  694.   (let ((mapname (sgml-check-name))
  695.     mappings literal name)
  696.     (while (progn
  697.          (sgml-skip-ps)
  698.          (setq literal (sgml-parse-parameter-literal 'dofunchar)))
  699.       (sgml-skip-ps)
  700.       (setq name (sgml-check-name t))
  701.       (push (cons literal name) mappings))
  702.     (sgml-add-shortref-map
  703.      (sgml-dtd-shortmaps sgml-dtd-info)
  704.      mapname
  705.      (sgml-make-shortmap mappings))))
  706.  
  707. ;;;152  short reference use declaration = MDO, "USEMAP",
  708. ;;;                        [[65 ps]]+, [[153 map specification]],
  709. ;;;                        ([[65 ps]]+, [[72 associated element type]])?,
  710. ;;;                        [[65 ps]]*, MDC
  711.  
  712. (defun sgml-do-usemap-element (mapname)
  713.   ;; This is called from sgml-do-usemap with the mapname
  714.   (sgml-before-eltype-modification)
  715.   (loop for e in (sgml-parse-name-group) do
  716.     (setf (sgml-eltype-shortmap (sgml-lookup-eltype e sgml-dtd-info))
  717.           (if (null mapname)
  718.           'empty
  719.         mapname))))
  720.  
  721.  
  722. ;;;; Parse doctype
  723.  
  724. (defun sgml-check-dtd-subset ()
  725.   (let ((sgml-parsing-dtd t)
  726.     (eref sgml-current-eref))
  727.     (while 
  728.     (progn
  729.       (setq sgml-markup-start (point))
  730.       (cond
  731.        ((and (eobp) (eq sgml-current-eref eref))
  732.         nil)
  733.        ((sgml-parse-ds))
  734.        ((sgml-parse-markup-declaration 'dtd))
  735.        ((sgml-parse-delim "MS-END")))))))
  736.  
  737.  
  738. ;;;; Save DTD: compute translation
  739.  
  740. (defvar sgml-translate-table nil)
  741.  
  742. (defun sgml-translate-node (node)
  743.   (assert (not (numberp node)))
  744.   (let ((tp (assq node sgml-translate-table)))
  745.     (unless tp
  746.       (setq tp (cons node (length sgml-translate-table)))
  747.       (nconc sgml-translate-table (list tp)))
  748.     (cdr tp)))
  749.  
  750. (defun sgml-translate-moves (moves)
  751.   (while moves
  752.     (sgml-translate-node (sgml-move-dest (car moves)))
  753.     (setq moves (cdr moves))))
  754.  
  755. (defun sgml-translate-model (model)
  756.   (let* ((sgml-translate-table (list (cons model 0)))
  757.      (p sgml-translate-table))
  758.     (while p
  759.       (cond ((sgml-normal-state-p (caar p))
  760.          (sgml-translate-moves (sgml-state-opts (caar p)))
  761.          (sgml-translate-moves (sgml-state-reqs (caar p))))
  762.         (t
  763.          (sgml-translate-node (sgml-and-node-next (caar p)))))
  764.       (setq p (cdr p)))
  765.     sgml-translate-table))
  766.  
  767. ;;;; Save DTD: binary coding
  768.  
  769. (defvar sgml-code-token-numbers nil)
  770. (defvar sgml-code-xlate nil)
  771.  
  772. (defsubst sgml-code-xlate (node)
  773.   ;;(let ((x (cdr (assq node sgml-code-xlate)))) (assert x) x)
  774.   (cdr (assq node sgml-code-xlate)))
  775.  
  776. (defun sgml-code-number (num)
  777.   (if (> num sgml-max-single-octet-number)
  778.       (insert (+ (lsh (- num sgml-max-single-octet-number) -8)
  779.          sgml-max-single-octet-number 1)
  780.           (logand (- num sgml-max-single-octet-number) 255))
  781.     (insert num)))
  782.  
  783. (defun sgml-code-token-number (token)
  784.   (let ((bp (assq token sgml-code-token-numbers)))
  785.     (unless bp
  786.       (setq sgml-code-token-numbers
  787.         (nconc sgml-code-token-numbers
  788.            (list (setq bp (cons token
  789.                     (length sgml-code-token-numbers)))))))
  790.     (cdr bp)))
  791.  
  792. (defun sgml-code-token (token)
  793.   (sgml-code-number (sgml-code-token-number token)))
  794.  
  795. (defmacro sgml-code-sequence (loop-c &rest body)
  796.   "Produce the binary coding of a counted sequence from a list.
  797. Syntax: (var seq) &body forms
  798. FORMS should produce the binary coding of element in VAR."
  799.   (let ((var (car loop-c))
  800.     (seq (cadr loop-c)))
  801.     (` (let ((seq (, seq)))
  802.      (sgml-code-number (length seq))       
  803.      (loop for (, var) in seq 
  804.            do (,@ body))))))
  805.  
  806. (put 'sgml-code-sequence 'lisp-indent-hook 1)
  807. (put 'sgml-code-sequence 'edbug-forms-hook '(sexp &rest form))
  808.  
  809. (defun sgml-code-sexp (sexp)
  810.   (let ((standard-output (current-buffer)))
  811.     (prin1 sexp)
  812.     (terpri)))
  813.  
  814. (defun sgml-code-tokens (l)
  815.   (sgml-code-sequence (x l)
  816.     (sgml-code-token x)))
  817.  
  818. (defsubst sgml-code-move (m)
  819.   (sgml-code-token (sgml-move-token m))
  820.   (insert (sgml-code-xlate (sgml-move-dest m))))
  821.  
  822. (defun sgml-code-model (m)
  823.   (let ((sgml-code-xlate (sgml-translate-model m)))
  824.     (sgml-code-sequence (s sgml-code-xlate)        ; s is (node . number)
  825.       (setq s (car s))            ; s is node
  826.       (cond
  827.        ((sgml-normal-state-p s)
  828.     (assert (and (< (length (sgml-state-opts s)) 255)
  829.              (< (length (sgml-state-reqs s)) 256)))
  830.     (sgml-code-sequence (x (sgml-state-opts s))
  831.       (sgml-code-move x))
  832.     (sgml-code-sequence (x (sgml-state-reqs s))
  833.       (sgml-code-move x)))
  834.        (t                ; s is a &-node
  835.     (insert 255)            ; Tag &-node
  836.     (insert (sgml-code-xlate (sgml-and-node-next s)))
  837.     (sgml-code-sequence (m (sgml-and-node-dfas s))
  838.       (sgml-code-model m)))))))
  839.  
  840. (defun sgml-code-element (et)
  841.   (sgml-code-sexp (sgml-eltype-all-miscdata et))
  842.   (cond
  843.    ((not (sgml-eltype-defined et))
  844.     (insert 128))
  845.    (t
  846.     (insert (sgml-eltype-flags et))
  847.     (let ((c (sgml-eltype-model et)))
  848.       (cond ((eq c sgml-cdata) (insert 0))
  849.         ((eq c sgml-rcdata) (insert 1))
  850.         ((eq c sgml-empty) (insert 2))
  851.         ((eq c sgml-any) (insert 3))
  852.         ((null c) (insert 4))
  853.         (t
  854.          (assert (sgml-model-group-p c))
  855.          (insert 128)
  856.          (sgml-code-model c))))
  857.     (sgml-code-tokens (sgml-eltype-includes et))
  858.     (sgml-code-tokens (sgml-eltype-excludes et)))))
  859.  
  860.  
  861. (defun sgml-code-dtd (dtd)
  862.   "Produce the binary coding of the current DTD into the current buffer."
  863.   (sgml-code-sexp (sgml-dtd-dependencies dtd))
  864.   (sgml-code-sexp (sgml-dtd-parameters dtd))
  865.   (sgml-code-sexp (sgml-dtd-doctype dtd))
  866.   (let ((done 0)            ; count written elements
  867.     tot)
  868.     (setq sgml-code-token-numbers nil)
  869.     (sgml-code-token-number sgml-pcdata-token) ; Make #PCDATA token 0
  870.     (sgml-map-eltypes            ; Assign numbers to all tokens
  871.      (function (lambda (et)
  872.          (sgml-code-token-number (sgml-eltype-token et))))
  873.      dtd nil t)
  874.     (setq tot (length sgml-code-token-numbers))
  875.     ;; Produce the counted sequence of element type names
  876.     (sgml-code-sequence (pair (cdr sgml-code-token-numbers))
  877.       (sgml-code-sexp (sgml-eltype-name (car pair))))
  878.     ;; Produce the counted sequence of element types
  879.     (sgml-code-sequence (pair (cdr sgml-code-token-numbers))
  880.       (setq done (1+ done))
  881.       (sgml-code-element (car pair))
  882.       (sgml-lazy-message "Saving DTD %d%% done" (/ (* 100 done) tot)))
  883.     (sgml-code-sexp (sgml-dtd-entities dtd))
  884.     (sgml-code-sexp (sgml-dtd-shortmaps dtd))
  885.     (sgml-code-sexp (sgml-dtd-notations dtd))))
  886.  
  887.  
  888. ;;;; Save DTD
  889.  
  890. (defun sgml-save-dtd (file)
  891.   "Save the parsed dtd on FILE."
  892.   (interactive
  893.    (let* ((tem (expand-file-name
  894.         (or sgml-default-dtd-file
  895.             (sgml-default-dtd-file))))
  896.       (dir (file-name-directory tem))
  897.       (nam (file-name-nondirectory tem)))
  898.      (list
  899.       (read-file-name "Save DTD in: " dir tem nil nam))))
  900.   (setq file (expand-file-name file))
  901.   (when (equal file (buffer-file-name))
  902.     (error "Would clobber current file"))
  903.   (sgml-need-dtd)
  904.   (sgml-push-to-entity (sgml-make-entity "#SAVE" nil ""))
  905.   (sgml-write-dtd sgml-dtd-info file)
  906.   (sgml-pop-entity)
  907.   (setq sgml-default-dtd-file
  908.     (if (equal (expand-file-name default-directory)
  909.            (file-name-directory file))
  910.         (file-name-nondirectory file)
  911.       file))
  912.   (setq sgml-loaded-dtd file))
  913.  
  914. (defun sgml-write-dtd (dtd file)
  915.   "Save the parsed dtd on FILE.
  916. Construct the binary coded DTD (bdtd) in the current buffer."
  917.   (insert
  918.    ";;; This file was created by psgml on " (current-time-string) "\n"
  919.    "(sgml-saved-dtd-version 6)\n")
  920.   (sgml-code-dtd dtd)
  921.   (setq file-type 1)
  922.   (write-region (point-min) (point-max) file))
  923.  
  924.  
  925. ;;; psgml-dtd.el ends here
  926.